TPUG - Toronto PET Users Group/TPUG Users Group CD/TPUG Users Group CD.iso/AMIGA/AMICUS/AMICUS18.ADF/Games/Decay/dk.mod

Text File | 1989-01-27 | 12KB | 412 lines

                                                                                                                                                                                                                                 (*$Q*)
MODULE DK;

(* A little fun, inspired by Leo Schwab's TILT *)

(* Author: Thomas H. Handel, PeopleLink ID -- THH -- *)

(* I'm still learning Modula-2 and programming on Amy, so this may not
   be the tidiest or best way to do what the program does.  Also, it is
   probably not the most elegant example of structured programming ever
   created.  Finally, I am certain that there are many enhancements that
   more experienced programmers will be able to add (like maybe a close
   gadget and the wherewithall to respond to it).  Please fiddle at will.     If you have comments or suggestions, please contact me on PeopleLink or    by U.S. Snail at:

   628 Harberts Ct.
   Annapolis, MD 21401

   Thanks in advance. *)

(* Placed in the Public Domain, 29 March 1987 *)

FROM SYSTEM IMPORT ADR, BYTE, NULL;
FROM Intuition IMPORT NewWindow, WindowPtr, IntuitionName, IntuitionBase,
                      WindowFlags, WindowFlagSet, IDCMPFlagSet,
                      CloseWindowFlag, ScreenFlagSet, WBenchScreen,
                      SmartRefresh,IntuiMessagePtr;
FROM Libraries IMPORT OpenLibrary, CloseLibrary;
FROM Windows IMPORT OpenWindow, CloseWindow;
FROM Strings IMPORT String;
FROM Pens IMPORT ReadPixel, WritePixel, SetAPen;
FROM GraphicsLibrary IMPORT GraphicsName, GraphicsBase;
FROM Ports IMPORT GetMsg, ReplyMsg, MessagePtr;
FROM Rasters IMPORT RastPortPtr;
FROM Storage IMPORT ALLOCATE, DEALLOCATE;
FROM RandomNumbers IMPORT Random;

VAR WPtr: WindowPtr;
    NWin: NewWindow;
    WNam: String;
    RprtPtr: RastPortPtr;
    MsgPtr : IntuiMessagePtr;



PROCEDURE Initialize(): BOOLEAN;  (* Open the libraries *)

BEGIN
   IntuitionBase := OpenLibrary(IntuitionName,0);
   GraphicsBase := OpenLibrary(GraphicsName,0);
   IF ((IntuitionBase = 0) OR (GraphicsBase = 0)) THEN RETURN FALSE
      ELSE RETURN TRUE;
   END;
END Initialize;


PROCEDURE InitWindow;  (* Set up and open the window *)

BEGIN
   WNam := "DK!";
   WITH NWin DO
      LeftEdge := 450;
      TopEdge := 0;
      Width := 100;
      Height := 10;
      DetailPen := BYTE(0);
      BlockPen := BYTE(1);
      IDCMPFlags := IDCMPFlagSet{CloseWindowFlag};
      Flags := SmartRefresh + WindowFlagSet{Activate, WindowClose,
               WindowDepth};
      FirstGadget := NULL;
      CheckMark := NULL;
      Title := ADR(WNam);
      Screen := NULL;
      BitMap := NULL;
      MinWidth := 0;
      MinHeight := 0;
      MaxWidth := 0;
      MaxHeight := 0;
      Type := ScreenFlagSet{WBenchScreen};
   END;
   WPtr := OpenWindow(NWin);
END InitWindow;


PROCEDURE Decay; (* Erode the display *)

   TYPE ColNodePtr = POINTER TO ColNode;
        ColNode = RECORD
                    Col  : CARDINAL;  (* X-value of column *)
                    Row  : CARDINAL;  (* Y-value of next non-zero pixel *)
                    PClr : CARDINAL;  (* Pixel Pen number *)
                    Next : ColNodePtr;  (* Forward pointer *)
                    Prev : ColNodePtr  (* Backward pointer *)
                  END;
        PixlNodePtr = POINTER TO PixlNode;
        PixlNode = RECORD
                     PClr : CARDINAL; (* Pixel color *)
                     CurX : CARDINAL; (* Current location, X-value *)
                     CurY : CARDINAL; (* Current location, Y-value *)
                     Next : PixlNodePtr; (* Forward pointer *)
                     Prev : PixlNodePtr (* Backward pointer *)
                   END;

   VAR ScrnTop   : CARDINAL;  (* Screen top *)
       TopEdge   : CARDINAL;  (* Screen top less title bar *)
       Bottom    : CARDINAL;  (* Screen bottom less border *)
       YStrt     : CARDINAL;  (* Four pixels above bottom *)
       ColCount  : CARDINAL;  (* Number of ColNodes in list *)
       ColHead   : ColNodePtr; (* Pointer to head of ColNode list *)
       CPtr      : ColNodePtr; (* Utility pointer for list traversal *)
       PixlCount : CARDINAL;  (* Number of PixlNodes in list *)
       PixlHead  : PixlNodePtr; (* Pointer to head of PixlNode list *)
       PPtr      : PixlNodePtr; (* Utility pointer for list traversal *)
       Depth     : ARRAY [2..637] OF CARDINAL; (* Depth of snow by col *)


   PROCEDURE ComputeParms;  (* Get some basic parameters *)

   BEGIN
      ScrnTop := WPtr^.WScreen^.TopEdge;
      TopEdge := ScrnTop + 10;
      Bottom := CARDINAL(WPtr^.WScreen^.Height) + ScrnTop - 1;
      YStrt := Bottom - 4;
   END ComputeParms;


   PROCEDURE InitVars;  (* Initialize Variables *)

   VAR I : INTEGER; (* Counter *)

   BEGIN
      FOR I := 2 TO 637 DO
         Depth[I] := 0
      END;
      RprtPtr := ADR(WPtr^.WScreen^.RPort);
      ColCount := 0;
      PixlCount := 0;
      ColHead := NIL;
      PixlHead := NIL
   END InitVars;


   PROCEDURE FindCols;  (* Create list of cols containing non-zero pixls *)
   VAR X    : CARDINAL; (* Column Counter *)
       Y    : CARDINAL; (* Row Counter *)
       Pixl : CARDINAL; (* Pen number of pixel *)

   BEGIN
      FOR X := 2 TO 637 DO
         Y := YStrt;
         LOOP
            Pixl := ReadPixel(RprtPtr,X,Y);
            IF Pixl <> 0 THEN
               NEW (CPtr);            (* Create node for list *)
               CPtr^.Col := X;
               CPtr^.Row := Y;
               CPtr^.PClr := Pixl;
               IF ColHead = NIL THEN  (* and link it in at head of list *)
                  CPtr^.Next := NIL;
                  CPtr^.Prev := NIL
               ELSE
                  CPtr^.Next := ColHead;
                  CPtr^.Prev := NIL;
                  ColHead^.Prev := CPtr
               END;
               ColHead := CPtr;
               CPtr := NIL;
               INC(ColCount);
               EXIT
            END;
            Y := Y - 1;
            IF Y <= TopEdge THEN
               EXIT
            END
         END
      END;
   END FindCols;


   PROCEDURE NewPixel;  (* Get a new pixel at random for snowflake ops *)

   VAR RNum : CARDINAL;  (* Random Number *)
       I    : CARDINAL;  (* Counter *)
       Pixl : CARDINAL;  (* Pen number of pixel *)


      PROCEDURE DeleteCol;  (* Remove an empty column from the list *)

      BEGIN
         IF CPtr = ColHead THEN
            IF CPtr^.Next <> NIL THEN
               ColHead := ColHead^.Next;
               ColHead^.Prev := NIL
            ELSE
               ColHead := NIL
            END
         ELSE
            IF CPtr^.Next = NIL THEN
               CPtr^.Prev^.Next := NIL
            ELSE
               CPtr^.Prev^.Next := CPtr^.Next;
               CPtr^.Next^.Prev := CPtr^.Prev
            END
         END;
         DISPOSE (CPtr);
         ColCount := ColCount - 1;
      END DeleteCol;


   BEGIN  (* NewPixel *)
      RNum := Random(ColCount - 1);     (* 0 <= RNum <= [ColCount-1] *)
      CPtr := ColHead;
      IF RNum > 0 THEN
         FOR I := 0 TO RNum DO
            CPtr := CPtr^.Next
         END
      END;
      NEW (PPtr);
      PPtr^.PClr := CPtr^.PClr;
      PPtr^.CurX := CPtr^.Col;
      PPtr^.CurY := CPtr^.Row;
      IF PixlHead = NIL THEN
         PPtr^.Next := NIL;
         PPtr^.Prev := NIL
      ELSE
         PPtr^.Next := PixlHead;
         PPtr^.Prev := NIL;
         PixlHead^.Prev := PPtr
      END;
      PixlHead := PPtr;
      INC(PixlCount);
      LOOP
         CPtr^.Row := CPtr^.Row - 1;
         IF CPtr^.Row < TopEdge THEN
            DeleteCol;
            EXIT
         ELSE
            Pixl := ReadPixel(RprtPtr,CPtr^.Col,CPtr^.Row);
            IF Pixl <> 0 THEN
               CPtr^.PClr := Pixl;
               EXIT
            END
         END
      END;
   END NewPixel;


   PROCEDURE MovePixels;  (* Make the snow fall *)

   VAR XDest : CARDINAL;  (* Pixel destination, X-value *)
       YDest : CARDINAL;  (* Pixel destination, Y-value *)
       DFlag : BOOLEAN;  (* Signals pixel ready for deletion from list *)
       RLFlag: BOOLEAN;  (* Direction of snow drift *)


      PROCEDURE DeletePixel;  (* Remove a pixel from the list *)

      VAR tPtr : PixlNodePtr;  (* Utility pointer *)

      BEGIN
         tPtr := PPtr;
         IF PPtr = PixlHead THEN
            IF PPtr^.Next <> NIL THEN
               PixlHead := PixlHead^.Next;
               PixlHead^.Prev := NIL
            ELSE
               PixlHead := NIL
            END;
            tPtr := PPtr;
            PPtr := PixlHead
         ELSE
            IF PPtr^.Next = NIL THEN
               PPtr^.Prev^.Next := NIL
            ELSE
               PPtr^.Prev^.Next := PPtr^.Next;
               PPtr^.Next^.Prev := PPtr^.Prev
            END;
            tPtr := PPtr;
            PPtr := PPtr^.Prev
         END;
         DISPOSE (tPtr);
         PixlCount := PixlCount - 1;
         DFlag := FALSE;
      END DeletePixel;


      PROCEDURE ComputeDest;  (* Compute a random destination for pixel *)

      BEGIN
         XDest := PPtr^.CurX + 8 - Random(16);
         YDest := PPtr^.CurY + Random(13);
         IF XDest <= 2 THEN
            XDest := 3 + Random(5)
         END;
         IF XDest >= 637 THEN
            XDest := 636 - Random(5)
         END;
         IF YDest > Bottom - Depth[XDest] THEN
            YDest := Bottom - Depth[XDest];
            DFlag := TRUE
         END;
      END ComputeDest;


      PROCEDURE Drift;  (* Keep the snow from stacking up in tall towers *)
      VAR ChgFlag : BOOLEAN;  (* Flags change in XDest *)


         PROCEDURE CheckLeft;  (* See if flake should drift left *)

         BEGIN
            IF Depth[XDest] > Depth[XDest-1] THEN
               XDest := XDest - 1;
               ChgFlag := TRUE
            END
         END CheckLeft;


         PROCEDURE CheckRight;  (* See if flake should drift right *)

         BEGIN
            IF Depth[XDest] > Depth[XDest+1] THEN
               INC(XDest);
               ChgFlag := TRUE
            END
         END CheckRight;

      BEGIN (* Drift *)
         ChgFlag := TRUE;
         WHILE (XDest > 2) AND (XDest < 637) AND (ChgFlag) DO
            ChgFlag := FALSE;
            IF RLFlag THEN
               CheckLeft;
               CheckRight
            ELSE
               CheckRight;
               CheckLeft
            END;
            YDest := Bottom - Depth[XDest] - 1
         END
      END Drift;


      PROCEDURE MoveOne;  (* Move one pixel to new destination *)

      BEGIN
         SetAPen(RprtPtr,0);
         WritePixel(RprtPtr,PPtr^.CurX,PPtr^.CurY);
         SetAPen(RprtPtr,PPtr^.PClr);
         WritePixel(RprtPtr,XDest,YDest);
         PPtr^.CurX := XDest;
         PPtr^.CurY := YDest;
      END MoveOne;

   BEGIN (* MovePixels *)
      RLFlag := TRUE;
      DFlag := FALSE;
      PPtr := PixlHead;
      WHILE PPtr <> NIL DO           (* While there are still flakes *)
         ComputeDest;                (* Find this one a new destination *)
         IF DFlag THEN               (* If it has landed *)
            Drift;                   (* See if it should roll R or L *)
            RLFlag := NOT(RLFlag)
         END;
         MoveOne;                    (* Actually move it to new dest *)
         IF DFlag THEN               (* If it has landed *)
            INC(Depth[XDest]);       (* increment depth in column *)
            DeletePixel              (* and remove pixel from list *)
         END;
         IF PPtr <> NIL THEN
            PPtr := PPtr^.Next
         END
      END
   END MovePixels;
   PROCEDURE DanceOff;  (* Clean things up *)

   BEGIN
      CloseWindow(WPtr);
      CloseLibrary(IntuitionBase);
      CloseLibrary(GraphicsBase);
   END DanceOff;

BEGIN (* Decay *)
   ComputeParms;
   InitVars;
   FindCols;
   REPEAT
      IF ColCount <> 0 THEN
         NewPixel
      END;
      IF PixlCount <> 0 THEN
         MovePixels
      END;
   MsgPtr := GetMsg(WPtr^.UserPort);
   IF MsgPtr <> NULL THEN
      ColCount := 0;
      PixlCount := 0;
      ReplyMsg (MessagePtr(MsgPtr));
   END;
   UNTIL (ColCount = 0) AND (PixlCount = 0);
   DanceOff;
END Decay;


BEGIN (* DK *)
   IF Initialize() THEN
     InitWindow;
     Decay;
   END;
END DK.